#lang racket


(require "../global.rkt")

(require "../ast/main.rkt"
         "../backends/main.rkt")

(require "constructor-defer.rkt")

(provide
 ; evaluate
 shapes
 evaluate
 evaluate-toplevel
 
 ; shapes
 bbox
 shapes<-loc
 select-shapes<-loc
 
 ; points
 point?
 point-c
 
 ; lines
 line?
 line-closed?
 polygonal-line?
 
 line-begin-c
 line-cs
 line-end-c
 
 ; surfaces
 surface-curvature
 surface-domain
 
 ; lang
 par
 
 ; cad
 clone-shape
 clone-shapes
 delete-shape
 delete-shapes
 get-shapes
 
 prompt-point
 prompt-shape
 
 draft
 presentation
 render-shapes
 
 select-shape
 select-shapes
 
 view!
 view-ortho-top!
 view-perspective!)


; utils

(define-syntax define-out-backend-evaluate
  (syntax-rules ()
    ((_ name)
     (define (name node)
       (send (current-out-backend) name (evaluate-toplevel node))))))


; evaluate

(define shapes (list))

(define (evaluate expr)
  (send (current-out-backend) evaluate expr))

; edit: bug recursion (eval is EVIL)
(define (evaluate-toplevel expr)
  (let ((res (send (current-out-backend) evaluate-toplevel expr)))
    (unless (is-a? (current-out-backend) null-backend%)
      (set! shapes (send (current-out-backend) get-cached-shapes)))
    res))


; shapes

(define-out-backend-evaluate bbox)


(define (srcloc-contains? srcloc file begin end)
  (and
   (equal? (srcloc-source srcloc) file)
   (let ((pos (srcloc-position srcloc)))
     (if (= begin end)
         (<= pos begin (+ pos (srcloc-span srcloc) -1))
         (<= begin pos (+ pos (srcloc-span srcloc)) end)))))

(define (srclocs-contain? srclocs file begin end)
  #;(srcloc-contains? (last srclocs) file begin end)
  (ormap (lambda (srcloc) (srcloc-contains? srcloc file begin end))
         srclocs))

(define (shapes<-loc file begin end)
  (let ((smallest-srcloc
         (let loop ((shapes shapes) (smallest #f))
           (if (empty? shapes)
               smallest
               (let ((shape (car shapes)))
                 (let find-srcloc ((srclocs (get-field srcloc (shape-node shape)))
                                   (smallest smallest))
                   (if (empty? srclocs)
                       (loop (cdr shapes) smallest)
                       (let ((srcloc (car srclocs)))
                         (if (srcloc-contains? srcloc file begin end)
                             (find-srcloc
                              (cdr srclocs)
                              (if (and smallest
                                       (< (srcloc-span smallest)
                                          (srcloc-span srcloc)))
                                  smallest
                                  srcloc))
                             (find-srcloc (cdr srclocs) smallest))))))))))
    (if smallest-srcloc
        (filter (lambda (shape)
                  (member smallest-srcloc (get-field srcloc (shape-node shape))))
                shapes)
        (list))))

(define (select-shapes<-loc file begin end)
  (let ((shapes (shapes<-loc file begin end)))
    (unless (empty? shapes)
      (unselect-all-shapes)
      (select-shapes 
       (filter (lambda (shape)
                 (send (shape-backend shape) valid-shape? shape))
               shapes))))) ;;Some shapes might have been consumed

; points

(define-out-backend-evaluate point?)
(define-out-backend-evaluate point-c)


; lines

(define-out-backend-evaluate line?)
(define-out-backend-evaluate line-closed?)
(define-out-backend-evaluate polygonal-line?)
(define-out-backend-evaluate line-begin-c)
(define-out-backend-evaluate line-cs)
(define-out-backend-evaluate line-end-c)


; surfaces

(define-out-backend-evaluate surface-curvature)
(define-out-backend-evaluate surface-domain)


; lang

(define-out-backend-evaluate par)


; cad

(define (clone-shape shape)
  (send (shape-backend shape) clone-shape shape))

(define (clone-shapes shapes)
  (map clone-shape shapes))

(define (delete-shape shape)
  (send (shape-backend shape) delete-shape shape))

(define (delete-shapes)
  (send (current-out-backend) delete-shapes))

(define (get-shapes)
  (send (current-out-backend) get-shapes))

(define (prompt-point message)
  (send (current-out-backend) prompt-point message))

(define (prompt-shape message)
  (send (current-out-backend) prompt-shape message))


; render-shapes

(define draft (draft-render-type))
(define presentation (presentation-render-type))

(define (render-shapes width height path type)
  (send (current-out-backend) render-shapes width height path type))

; /render-shapes


(define (select-shape shape)
  (send (shape-backend shape) select-shape shape))

(define (select-shapes shapes)
  (for-each select-shape shapes))

(define (unselect-all-shapes)
  (send (current-out-backend) unselect-all-shapes))

; edit: getting all the shapes has a significant performance impact; imperative version of 'view'?
(define (view! . args)
  (let* ((shapes (get-shapes))
         (node (apply view (append args (list shapes)))))
    (void (evaluate node))))

; edit: see view!
(define (view-ortho-top! . args)
  (let* ((shapes (get-shapes))
         (node (apply view-ortho-top (append args (list shapes)))))
    (void (evaluate node))))

; edit: see view!
(define (view-perspective! . args)
  (let* ((shapes (get-shapes))
         (node (apply view-perspective (append args (list shapes)))))
    (void (evaluate node))))